home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d3 / dbsteel3.arc / SORTINT.BAS < prev    next >
BASIC Source File  |  1991-01-21  |  12KB  |  437 lines
  1. 3 ON ERROR GOTO 64200
  2. 4 DEFINT K,F,T,L,R,N
  3. 5 DIM K$(55)
  4. 6 DIM FLDN$(1,60),FTY(1,60),FL(1,60)
  5. 7 DEFINT X,P
  6. 8 DIM X(10000),T(10000),NREC(17),FD(3),Z$(60),L(100),R(100),F$(17)
  7. 10 MAXR= 6
  8. 12 GOSUB 8000
  9. 15 GOSUB 13000
  10. 16 H = A
  11. 17 GOSUB 7000
  12. 19 DEFSTR Z
  13. 20 A = H
  14. 25 GOSUB 9000
  15. 30 FLG = 0
  16. 45 L = 0
  17. 50 FOR T = 1 TO NREC(A)
  18. 55 L = L + FL(A,T)
  19. 60 NEXT T
  20. 70 DEFINT T
  21. 90 GOSUB 11000
  22. 100 GOSUB 10000
  23. 400 REM ******  GET DATA FROM DISKS  *******
  24. 405 GOSUB 16000
  25. 420 FOR T = 1 TO 30000 
  26. 429 IF T > MRN GOTO 26000
  27. 430 GET #1,T
  28. 433 REM
  29. 435 N = FD(1)
  30. 436 IF FTY(1,N) = 1 GOTO 500
  31. 438 IF T1 = 1 THEN X(T) = 0
  32. 439 X(T) = X(T)*1E+06    
  33. 440 ON FTY(1,N) GOTO 500,550,600,650,650
  34. 500 REM *** LET X(T) = Z$(N)
  35. 510 GOTO 700
  36. 550 X(T) = CVI(Z$(N)) + X(T)
  37. 560 GOTO 700
  38. 600 X(T) = CVS(Z$(N)) + X(T)
  39. 610 GOTO 700
  40. 650 X(T) = CVD(Z$(N)) + X(T)
  41. 700 REM
  42. 705 T(T) = T
  43. 710 NEXT T
  44. 1200 LP = 1   
  45. 1210 FLG = 0
  46. 2000 REM
  47. 2010 M = 5000
  48. 2020 GOSUB 30000
  49. 2110 GOSUB 2200
  50. 2120 GOSUB 30000
  51. 2130 GOTO 3000
  52. 2200 REM
  53. 2210 L(1) = 1 
  54. 2220 R(1) = MAXR
  55. 2230 S = 1
  56. 2240 IF (L(S)) < R(S) THEN 2270
  57. 2250    S = S - 1
  58. 2260    GOTO 2640
  59. 2270 I = L(S)
  60. 2280 J = R(S)
  61. 2290 P1= X(J)
  62. 2300 M = (I + J)/2
  63. 2310 IF (J - I<6) THEN 2400
  64. 2320 IF ((P1>X(I)) AND (P1<X(M))) THEN 2400
  65. 2330 IF ((P1<X(I)) AND (P1>X(M))) THEN 2400
  66. 2340 IF ((X(I)<X(M)) AND (X(I)>P1)) THEN 2380
  67. 2350 IF ((X(I)>X(M)) AND (X(I)<P1)) THEN 2380
  68. 2360 SWAP X(M),X(J)
  69. 2365 SWAP T(M),T(J)
  70. 2370 GOTO 2390
  71. 2380 SWAP X(I),X(J)
  72. 2385 SWAP T(I),T(J)
  73. 2390 P1 = X(J)
  74. 2400 WHILE (I<J)          
  75. 2410 WHILE (X(I)< P1)   
  76. 2420 I = I + 1
  77. 2430 WEND     
  78. 2440 J=J-1
  79. 2450 WHILE  (I<J)AND(P1<X(J))  
  80. 2460 J = J-1
  81. 2470 WEND     
  82. 2480 IF (I>=J) THEN 2510
  83. 2490 SWAP X(I),X(J)
  84. 2500 SWAP T(I),T(J)
  85. 2510 WEND      
  86. 2520 J = R(S)
  87. 2530 SWAP X(I),X(J)
  88. 2540 SWAP T(I),T(J)
  89. 2550 IF (I - L(S)>=R(S)-I) THEN 2600
  90. 2560    L(S + 1) = L(S)
  91. 2570    R(S + 1) = I - 1
  92. 2580    L(S) = I + 1
  93. 2590    GOTO 2630
  94. 2600    L(S + 1) = I + 1
  95. 2610    R(S + 1) = R(S)
  96. 2620    R(S) = I - 1 
  97. 2630 S = S + 1
  98. 2640 IF (S > 0) THEN 2240
  99. 2650 RETURN
  100. 3000 REM ********  PUT IN FILE ************
  101. 3100 GOSUB 9100
  102. 3110 Q$ = "B:"+F$(A)
  103. 3200 GOSUB 9200
  104. 3300 FOR Q = 1 TO MAXR
  105. 3310 RN = T(Q)
  106. 3312 GET #1,RN
  107. 3330 LSET Z1$ = Y$
  108. 3340 PUT #2,Q
  109. 3350 NEXT Q
  110. 3500 CLOSE
  111. 3600 GOSUB 15000
  112. 3620 PRINT "SORT FINISHED "
  113. 3630 END
  114. 7000 GOSUB 12000
  115. 7005 OPEN "I",#1,"FFILE"
  116. 7010 INPUT #1,MAXF
  117. 7020 FOR A = 1 TO MAXF
  118. 7030 INPUT #1,A,F$(A),NREC(A),L(A)
  119. 7040 FOR N = 1 TO NREC(A)
  120. 7050 INPUT #1,FLDN$(1,N),FTY(1,N),FL(1,N)
  121. 7055 IF FTY(1,N) = 2 THEN INPUT #1,KY,KEYLIST
  122. 7060 NEXT N
  123. 7065 IF A = AHLD THEN RETURN
  124. 7070 NEXT A
  125. 7080 CLOSE #1
  126. 7100 RETURN
  127. 8000 GOSUB 12000
  128. 8005 OPEN "I",#1,"FFILE"
  129. 8010 INPUT #1,MAXF
  130. 8020 FOR A = 1 TO MAXF
  131. 8030 INPUT #1,A,F$(A),NREC(A),L(A)
  132. 8040 FOR N = 1 TO NREC(A)
  133. 8050 INPUT #1,FLDN$(1,N),FTY(1,N),FL(1,N)
  134. 8055 IF FTY(1,N) = 2 THEN INPUT #1,KY,KEYLIST
  135. 8060 NEXT N
  136. 8070 NEXT A
  137. 8080 CLOSE #1
  138. 8100 RETURN
  139. 9000 REM *******  OPEN FILE SUBROUTINE  *******
  140. 9010 CLOSE #1
  141. 9020 OPEN "R",#1,F$(A),L(A)
  142. 9030 D = 0
  143. 9040 FOR T = 1 TO NREC(A)
  144. 9050 FIELD #1,D AS D$,FL(1,T) AS Z$(T)
  145. 9060 D = D + FL(1,T)
  146. 9070 NEXT T
  147. 9080 RETURN
  148. 9100 REM *******  OPEN FILE SUBROUTINE  *******
  149. 9110 CLOSE #1
  150. 9120 OPEN "R",#1,F$(A),L   
  151. 9140 PRINT " L(A) ";L   
  152. 9150 FIELD #1,L AS Y$    
  153. 9180 RETURN
  154. 9200 REM *******  OPEN FILE SUBROUTINE  *******
  155. 9210 CLOSE #2
  156. 9220 OPEN "R",#2,Q$,L
  157. 9250 FIELD #2,L AS Z1$
  158. 9280 RETURN
  159. 10000 REM *******  INITAL SELECTION  ********
  160. 10010 GOSUB 15000
  161. 10100 PRINT "**************  SORT FILE PROGRAM  **************"
  162. 10105 PRINT "FILE NUMBER = ";A;" FILE NAME = ";F$(A)
  163. 10110 PRINT ""
  164. 10120 FOR T = 1 TO NREC(A)
  165. 10130 PRINT T;"- ";FLDN$(A,T)
  166. 10140 NEXT T
  167. 10150 PRINT ""
  168. 10200 PRINT "***  WHICH FIELD IS THE PRIMARY SORT FIELD ?  ***"
  169. 10210 GOSUB 60000
  170. 10212 IF DT#<1 OR DT#>NREC(A) GOTO 10210
  171. 10213 IF FTY(1,DT#) <> 2 THEN GOTO 10210
  172. 10215 T3 = FD(1)
  173. 10218 FD(1) = DT#
  174. 10219 T3 = DT#
  175. 10220 GOTO 10275 
  176. 10230 PRINT "***********  WHICH FIELD IS THE SECONDARY FIELD ?  **********"
  177. 10232 PRINT "- If the primary values are equal"  
  178. 10234 PRINT "the record with the lowest secondary value will be stored first "
  179. 10240 GOSUB 60000
  180. 10242 IF DT#<1 OR DT#>NREC(A) GOTO 10240
  181. 10244 IF FTY(1,DT#) = 1 GOTO 10410
  182. 10246 FD(2) = DT#
  183. 10250 IF KTH= 2 GOTO 10275
  184. 10260 PRINT "************  WHICH FIELD IS THE THIRD FIELD  ? *************"
  185. 10262 PRINT "- If both the primary value and the secondary value are equal"
  186. 10264 PRINT "the record with the lowest third value will be stored first"
  187. 10270 GOSUB 60000
  188. 10272 IF DT#<1 OR DT#>NREC(A) GOTO 10270
  189. 10273 IF FTY(1,DT#) = 1 GOTO 10410
  190. 10274 FD(3) = DT#
  191. 10275 ON FTY(1,T3) GOSUB 10400,10600,10500,10500,10500
  192. 10280 RETURN
  193. 10400 REM ***DEFSTR X,P
  194. 10410 IF KTH> 1 THEN PRINT "********  STRING VARIABLES MAY ONLY BE SORTED BY ONE FIELD  ********"
  195. 10420 IF KTH> 1 GOTO 10100
  196. 10430 REM ***DIM X(4200),T(4200)
  197. 10490 RETURN
  198. 10500 REM *****DEFDBL X,P
  199. 10505 REM *****DIM X(4200),T(4200)
  200. 10510 RETURN
  201. 10600 IF KTH> 1 GOTO 10500
  202. 10610 REM ***DEFINT X,P
  203. 10620 REM ***DIM X(10000),T(10000)
  204. 10630 RETURN
  205. 11000 REM  *******  INTRODUCTION  ********
  206. 11100 GOSUB 15000
  207. 11110 PRINT "************************  SORT PROGRAM  *************************"
  208. 11120 PRINT ""
  209. 11130 PRINT "FILE NUMBER : ";A;" FILE NAME : ";F$(A)
  210. 11140 PRINT ""
  211. 11200 PRINT ""
  212. 11210 PRINT "Up to 10000 records may be sorted on ONE INTEGER FIELD "
  213. 11220 PRINT "Up to  4200 records may be sorted on ONE ALFANUMRIC FIELDS "
  214. 11230 PRINT "Up to  4200 records may be sorted on THREE DIFFERENT NUMERIC FIELDS"
  215. 11300 PRINT ""
  216. 11310 PRINT "The sort program reads the file on the default disk drive, sorts"
  217. 11320 PRINT "the records, then writes a sorted file with the same file name"
  218. 11330 PRINT "on a disk drive B. "
  219. 11940 PRINT ""
  220. 11950 PRINT "******************  PRESS ANY KEY TO CONTINUE  ******************"
  221. 11960 IF INKEY$ = "" GOTO 11960
  222. 11970 RETURN
  223. 12000 REM *****
  224. 12005 GOSUB 15000
  225. 12010 PRINT " PUT THE PROGRAM DATA DISK IN THE DEFAULT DISK DRIVE "
  226. 12020 PRINT ""
  227. 12030 PRINT "          PRESS ANY KEY TO CONTINUE "
  228. 12040 IF INKEY$ = "" GOTO 12040
  229. 12050 RETURN
  230. 13000 REM *****  
  231. 13100 GOSUB 15000
  232. 13110 PRINT "******************  SORT PROGRAM  *******************"
  233. 13120 PRINT ""
  234. 13130 PRINT "**********  WHICH FILE DO YOU WANT TO SORT  *********"
  235. 13140 FOR T = 1 TO MAXF
  236. 13150 PRINT T;" - ";F$(T)
  237. 13160 NEXT T
  238. 13170 PRINT "*****  ENTER THE FILE NUMBER THEN PRESS RETURN  ******"
  239. 13180 GOSUB 60000
  240. 13185 IF DT#<1 OR DT# >MAXF GOTO 13180
  241. 13190 A = DT#
  242. 13195 AHLD = A
  243. 13200 RETURN
  244. 14000 REM *****  SORT SELECTION
  245. 14100 GOSUB 15000
  246. 14110 PRINT "*******************  SORT PROGRAM  ********************"
  247. 14120 PRINT ""
  248. 14130 PRINT "DO YOU WANT TO SORT A FILE ON :"
  249. 14140 PRINT ""
  250. 14150 PRINT " 1. ONLY ONE INTEGER FIELD"
  251. 14160 PRINT ""
  252. 14170 PRINT " 2. ONE TO THREE NUMERIC FIELDS "
  253. 14180 PRINT ""
  254. 14190 PRINT " 3. A STRING FIELD"
  255. 14200 PRINT ""
  256. 14300 PRINT "*******  ENTER THE NUMBER THEN PRESS RETURN  ********"
  257. 14400 GOSUB 60000
  258. 14410 T = DT#
  259. 14420 ON T GOTO 14500,14700,14900
  260. 14500 REM 
  261. 14520 GOSUB  12000
  262. 14540 RUN "SORTINT"
  263. 14700 GOTO 10
  264. 14900 REM 
  265. 14920 GOSUB 12000
  266. 14940 RUN "SORTSTR"
  267. 15000 REM CLEAR SCREEN
  268. 15010 CALL CSCREEN 
  269. 15020 RETURN
  270. 16000 REM ******  FIND MAX RECORD 
  271. 16100 MRN = LOF(1)/L(A)
  272. 16200 RETURN
  273. 26000 REM ******* ON ERROR ROUTINE ************
  274. 26200 PRINT "END OF FILE"
  275. 26205 MAXR = T - 1
  276. 26206 PRINT MAXR," MAX RECORD "
  277. 26210 GOTO 1200
  278. 30000 FOR T = 1 TO MAXR
  279. 31000 PRINT X(T)
  280. 32000 NEXT T
  281. 33000 RETURN
  282. 60000 REM *******  INTEGER LESS THEN 100 CHECK  ********
  283. 60010 MAX = 2
  284. 60020 ACT$ = "1234567890"
  285. 60030 PRINT ">__<";
  286. 60040 GOTO 60200
  287. 60050 REM *******  INTEGER *******                        
  288. 60060 MAX = 8
  289. 60070 ACT$ = "1234567890-+,"
  290. 60080 PRINT ">________<";
  291. 60090 GOTO 60200
  292. 60100 REM *******  SINGLE PRECISION  *******                        
  293. 60110 MAX = 10
  294. 60120 ACT$ = "1234567890+-,.%$"
  295. 60130 PRINT ">__________<";
  296. 60140 GOTO 60200
  297. 60150 REM ********* DOUBLE PRECISION
  298. 60160 MAX = 20
  299. 60170 ACT$ = "1234567890+-,.%$"
  300. 60180 PRINT ">____________________<";
  301. 60190 GOTO 60200
  302. 60200 REM ********** NUMBER CHECK **********
  303. 60210 A$ = ""
  304. 60220 K$(20) = " "
  305. 60230 KTMAX = 0
  306. 60240 FOR T9 = 1 TO MAX
  307. 60250 K$(T9) = " "
  308. 60260 NEXT T9
  309. 60270 DIG$ = "1234567890."
  310. 60280 DOTFLG = 0
  311. 60290 T2 = MAX + 1
  312. 60300 FOR T6 = 1 TO T2
  313. 60310 PRINT CHR$(8);
  314. 60320 NEXT T6
  315. 60330 IF INKEY$ = "" GOTO 60340 ELSE GOTO 60330
  316. 60340 KT = 0
  317. 60350 REM ***********  CHECK ALFANUMERIC INPUT FOR LENGTH  ***********
  318. 60360 KT = KT + 1
  319. 60370 REM     
  320. 60380 W$ = INKEY$
  321. 60390 IF W$ = "" GOTO 60380
  322. 60400 C = ASC(W$)
  323. 60410 IF C = 0 THEN GOSUB 61900
  324. 60420 IF C = 13 GOTO 60540
  325. 60430 IF C = 17 GOTO 61130
  326. 60440 IF C = 19 GOTO 60670
  327. 60450 IF C = 4 GOTO 60720
  328. 60460 IF C = 6 GOTO 60780
  329. 60470 IF C = 1 GOTO 60950
  330. 60480 IF KT > MAX GOTO 60370
  331. 60490 IF INSTR(ACT$,W$) = 0 GOTO 61210
  332. 60500 K$(KT) = W$
  333. 60510 PRINT K$(KT);
  334. 60520 IF KT > KTMAX THEN KTMAX = KT
  335. 60530 GOTO 60360
  336. 60540 REM **********  RETURN  **********
  337. 60550 FOR T9 = 1 TO KTMAX
  338. 60560 A$ = A$ + K$(T9)
  339. 60610 NEXT T9
  340. 60620 IF KTMAX = 0 THEN PRINT "1"
  341. 60630 IF KTMAX = 0 THEN DT# = 1
  342. 60640 IF KTMAX = 0 THEN RETURN
  343. 60650 PRINT ""
  344. 60660 GOTO 61240
  345. 60670 REM ********* MOVE CURSE BACK ********
  346. 60680 IF KT = 1 GOTO 60370
  347. 60690 KT = KT - 1
  348. 60700 PRINT CHR$(8);
  349. 60710 GOTO 60370
  350. 60720 REM ********* MOVE CURSER FORWARD *********
  351. 60730 IF KT >= MAX GOTO 60370
  352. 60740 IF KT > (KTMAX + 1) GOTO 60370
  353. 60750 PRINT K$(KT);
  354. 60760 KT = KT + 1
  355. 60770 GOTO 60370
  356. 60780 REM ********** INSERT ***********
  357. 60790 IF KT > KTMAX GOTO 60370
  358. 60800 X9 = MAX
  359. 60810 WHILE X9 > KT
  360. 60820 X9 = X9 - 1
  361. 60830 K$(X9 + 1) = K$(X9)
  362. 60840 WEND 
  363. 60850 K$(KT) = " "
  364. 60860 KTMAX = KTMAX + 1
  365. 60870 FOR T9 = KT TO KTMAX
  366. 60880 PRINT K$(T9);
  367. 60890 NEXT T9
  368. 60900 T6 = (KTMAX - KT) + 1
  369. 60910 FOR T7 = 1 TO T6
  370. 60920 PRINT CHR$(8);
  371. 60930 NEXT T7
  372. 60940 GOTO 60370
  373. 60950 REM ********** DELETE ***********
  374. 60960 IF KT > KTMAX GOTO 60370
  375. 60970 K$(MAX + 1) = ""
  376. 60980 X9 = KT 
  377. 60990 WHILE X9 <= MAX
  378. 61000 K$(X9) = K$(X9 + 1)
  379. 61010 X9 = X9 + 1
  380. 61020 WEND 
  381. 61030 KTMAX = KTMAX - 1
  382. 61040 FOR T9 = KT TO KTMAX
  383. 61050 PRINT K$(T9);
  384. 61060 NEXT T9
  385. 61070 PRINT "_";
  386. 61080 T7 = (KTMAX - KT) + 2
  387. 61090 FOR T8 = 1 TO T7
  388. 61100 PRINT CHR$(8);
  389. 61110 NEXT T8
  390. 61120 GOTO 60370
  391. 61130 REM ********* BACKSPACE ********
  392. 61140 IF KT = 1 GOTO 60370
  393. 61150 KT = KT - 1
  394. 61160 PRINT CHR$(8);
  395. 61170 K$(KT) = " " 
  396. 61180 PRINT "_";
  397. 61190 PRINT CHR$(8);
  398. 61200 GOTO 60370
  399. 61210 REM *******  INPUT NOT ACCEPTABLE  ********
  400. 61220 PRINT CHR$(7);
  401. 61230 GOTO 60380
  402. 61240 REM ********* CLEAR STRINGS ********
  403. 61250 MAX = LEN(A$)
  404. 61260 D2$ = ""
  405. 61270 D1$ = ""
  406. 61280 DFLG = 0
  407. 61290 FOR Q93 = 1 TO MAX
  408. 61300 R$ = MID$(A$,Q93,1)
  409. 61310 IF INSTR(DIG$,R$) = 0 GOTO 61380
  410. 61320 IF R$ = "." OR DFLG = 1 GOTO 61360
  411. 61330 IF DFLG = 1 GOTO 61360
  412. 61340 D2$ = D2$ + R$
  413. 61350 GOTO 61380
  414. 61360 D1$ = D1$ + R$
  415. 61370 DFLG = 1
  416. 61380 NEXT Q93
  417. 61390 DA# = VAL(D2$)
  418. 61400 D1# = VAL(D1$)
  419. 61410 DT# = DA# + D1#
  420. 61420 IF K$(1) = "-" THEN DT# =  -DT#   
  421. 61430 RETURN
  422. 61900 REM ****** CHECK FOR ASC0
  423. 61910 S4$ = INKEY$
  424. 61920 C2 =  ASC(S4$)
  425. 61930 IF C2 = 83 THEN C = 1
  426. 61940 IF C2 = 82 THEN C = 6
  427. 61950 IF C2 = 75 THEN C = 19
  428. 61960 IF C2 = 77 THEN C = 4 
  429. 61970 RETURN
  430. 64200 REM
  431. 64210 PRINT " ERROR NUMBER ";ERR ; " ON LINE ";ERL
  432. 64270 CLOSE 
  433. 64280 PRINT " PRESS ANY KEY TO CONTINUE"
  434. 64290 IF INKEY$ = "" THEN 64290
  435. 64300 RESUME 3 
  436. R ; " ON LINE ";ERL
  437. 64270 CLOSE